home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The 640 MEG Shareware Studio 2
/
The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO
/
prog
/
uniforth.zip
/
FORTH.FTH
next >
Wrap
Text File
|
1985-08-20
|
20KB
|
1 lines
*********** THE UNIFORTH SAMPLER ************** FORTH.FTH is the default file, and contains the segment utility as well as the sysgen program. There are empty blocks at the end of the file for your own use. Copyright (c) 1985 Unified Software Systems P.O. Box 2644, New Carrollton, MD 20784 (301) 552-9590 ( Segment Utility -- 1 041783 aah) CODE MYSEG ( --- n ...get current segment) DS AX MOV, APUSH, END-CODE CODE SEG@ ( seg adr --- n ...fetch w/segment) BX POP, DS DX MOV, DS POP, [BX] AX MOV, DX DS MOV, APUSH, END-CODE CODE SEGC@ ( seg adr --- b ...fetch byte w/segment) BX POP, DS DX MOV, DS POP, [BX] AL MOV, AH AH XOR, DX DS MOV, APUSH, END-CODE CODE SEG! ( val seg adr --- ...store using segmented adr) DS DX MOV, BX POP, DS POP, AX POP, AX [BX] MOV, DX DS MOV, NEXT, END-CODE CODE SEGC! ( byte seg adr --- ...store using segment adr) DS DX MOV, BX POP, DS POP, AX POP, AL [BX] MOV, DX DS MOV, NEXT, END-CODE --> ( Segment Utility -- 2 120383 aah) SUBROUTINE >SEG ( 20-bit adr in AH:BX converted ) ( to segment in AX and displacement in BX) AH AL XCHG, BL AL MOV, 15 # AL AND, BX SHL, AH RCL, BX SHL, AH RCL, BX SHL, AH RCL, BX SHL, AH RCL, AL BL MOV, BH AL MOV, BH BH XOR, RET, END-CODE CODE L@ ( longadr --- val ...fetch w/20bit adr) BX POP, AX POP, >SEG CALL, DS DX MOV, AX DS MOV, [BX] AX MOV, DX DS MOV, APUSH, END-CODE CODE L! ( longadr --- val ...store w/20bit adr) BX POP, AX POP, >SEG CALL, DS DX MOV, AX DS MOV, AX POP, AX [BX] MOV, DX DS MOV, NEXT, END-CODE --> ( Segment Utility -- 3 042685AAH) CODE ADR>SEG ( longadr --- seg adr ...high-level) BX POP, AX POP, >SEG CALL, AX PUSH, BX PUSH, NEXT, END-CODE CODE SEG>ADR ( seg adr -- longadr ...convert to 32bit) DX POP, AX POP, 0 # BX MOV, AX SHL, BX RCL, AX SHL, BX RCL, AX SHL, BX RCL, AX SHL, BX RCL, DX AX ADD, 0 # BX ADC, BX PUSH, APUSH, END-CODE CODE SEGCMOVE ( seg src seg dst #bytes --- ) CX POP, DI POP, DX POP, BX POP, AX POP, AX DS MOV, DX ES MOV, SI BX XCHG, REP BYTE MOVS, CS AX MOV, AX ES MOV, AX DS MOV, SI BX XCHG, NEXT, END-CODE : LCMOVE ( dsrc ddst #bytes --- ) >R 2>R ADR>SEG 2R> ADR>SEG R> SEGCMOVE ; ;S ;S ( UNIFORTH SYSGEN load block 042685AAH) FORTH DEFINITIONS DECIMAL ( return vocabulary to FORTH) ' FORTH >BODY 12 +ORIGIN 10 CMOVE ( store state of vocab) HERE 36 +ORIGIN ! ( FENCE) HERE 38 +ORIGIN ! ( D.P.) VOC-LINK @ 40 +ORIGIN ! ( VOC-LINK) : GETVALS ( input number routine for reallocate) CR ." Number of blocks (2 to n):" GETNUM CR ." New memory size in Kbytes (24-64):" GETNUM 64 MIN CR ; : ENDALL ( print terminating messages for reallocate) ." End reallocate. SYSGEN or COLD to use new limits" CR ; : REALLOCATE ( change init memory size and #buffers) GETVALS DUP 64 = IF DROP 65534 ELSE 1024 * THEN LIMIT @ - OVER #BUFF @ - B/BUF 8 + * - 32 24 DO DUP I +ORIGIN +! 2 +LOOP 42 +ORIGIN +! 44 +ORIGIN ! ENDALL ; --> ( UNIFORTH SYSGEN -- 2 040585AAH) : SYSGEN ( Main word..requires all set B4 execute) CLOSE 0 FCB>TOS DROP CR ( close cur, save fcb on tos) ." Enter new compiled file name, like 'FTH.COM':" CR PAD 63 EXPECT CR 0 PAD SPAN @ + C! ( get path&null) PAD FCB @ 1+ 63 CMOVE ( move to fcb) FCB @ 1+ 0 CREATE-FILE FCB @ C! ( create com file) 38 +ORIGIN @ 0 +ORIGIN - US>D ( size of image) 1024 UM/MOD SWAP IF 1 ELSE 0 THEN + 0 DO ( #blks to write) I 1024 * +ORIGIN I BUFFER 1024 CMOVE UPDATE LOOP FCB 0 +ORIGIN - US>D 1024 UM/MOD BLOCK + 128 SWAP ! UPDATE CLOSE TOS>FCB FCB @ DUP 1+ 2 OPEN-FILE SWAP C! ; --> ( UNIFORTH SYSGEN -- 3 040585AAH) : (SCRAMBLE) ( perform the actual scramble of links) 14 +ORIGIN PAD 40 + 8 CMOVE BEGIN PAD 40 + (LATEST) SWAP ?DUP WHILE NAME> >LINK DUP @ ROT ! 0 SWAP ! REPEAT DROP ; : SCRAMBLE ( OEM development tool...wipes out links) ( use this word on your sysgen, and no royalties) ( are required) CR ." SCRAMBLE...Are you sure?" Y/N 0> IF CR ." Have you set TURNKEY? " Y/N 0> IF (SCRAMBLE) SYSGEN CR ." Finished scrambling...now rebooting!!" BYE THEN THEN ; --> ;S ;S ( The game of STARS) ( Courtesy of W. Ragsdale) VARIABLE TRIES VARIABLE RANDOM 60 RANDOM ! : -STARS 0 DO ." *" LOOP ; : AWARD 4 SPACE 32 -STARS CR ." That's it !!! You guessed my cosmic number in " TRIES @ . ." tries " ; : HINT 4 SPACES 64 SWAP / 2/ 1+ DUP RANDOM +! -STARS CR ; : WIN? OVER - DUP 0< IF NEGATE THEN DUP IF HINT FALSE ELSE DROP AWARD TRUE THEN ; : MORE? CR ." Do you want to play again?? " Y/N ; --> ( The game of STARS -- 2 ) : GUESS ( -- num ..take care of user input) BEGIN GETNUM PRECIS @ 0< IF CR DROP ." Give me a real number! " FALSE ELSE DUP RANDOM +! 1 TRIES +! TRUE THEN UNTIL ; : SELECT RANDOM @ 101 MOD 0 TRIES ! ; : SHORT CR ." I have a number. What is your guess?? " CR ; : INSTRUCTIONS CR CR ." I will select a number from 1 to 100 " CR ." Type in your guess and hit <return>. " CR ." If you are close I'll tell you by showing stars. " 8 -STARS CR ; --> ( The game of stars -- 3) : STARS 0 BLK ! 0 TRIES ! DECIMAL INSTRUCTIONS BEGIN SHORT SELECT BEGIN GUESS WIN? UNTIL MORE? NOT UNTIL CR CR ." Thanks, see you later " CR CR 10 SPACES ; --> ;S ( *** EXTENSIONS TO MAKE SYSTEM TRUE FORTH-83 *** ) : UM* USS*D ; : .( A' ) WORD COUNT TYPE ; : FORTH-83 ; ;S ( *** IBM-PC Color Graphics Interface *** ) HEX CODE MODE ( val --- ...sets video mode) AX POP, VIDEO CALL, NEXT, END-CODE 3 CONSTANT TEXT 6 CONSTANT GRAPHICS VARIABLE ATTR ( attribute for line plot) 7 ATTR ! CODE PALLETE ( val --- ...set color palette) 09 # AH MOV, BX POP, VIDEO CALL, NEXT, END-CODE CODE !DOT ( x y color --- ...plot dot) AX POP, 0C # AH MOV, DX POP, CX POP, VIDEO CALL, NEXT, END-CODE CODE @DOT ( x y --- val ...read dot) 0D # AH MOV, DX POP, CX POP, VIDEO CALL, 0 # AH MOV, APUSH, END-CODE DECIMAL --> ( Color Graphics Interface -- 2) 2VARIABLE INCR : XBIGGER ( x1 y1 x2 y2 --- ...plot where x2-x1 > y2-y1) 3 PICK 2 PICK > IF 2SWAP THEN 4DUP ROT - ROT ROT SWAP - SWAP 1000 SS*D ROT M/MOD S>D INCR 2! 2DROP SWAP 1000 SS*D 3 ROLL 3 ROLL SWAP DO 2DUP 1000 M/MOD SWAP DROP I SWAP ATTR @ !DOT INCR 2@ D+ LOOP 2DROP ; : YBIGGER ( x1 y1 x2 y2 --- ...plot where y2-y1 > x2-x1) 2 PICK OVER > IF 2SWAP THEN 4DUP ROT - ROT ROT SWAP - 1000 SS*D ROT M/MOD S>D INCR 2! DROP SWAP DROP ROT 1000 SS*D 3 ROLL 3 ROLL SWAP DO 2DUP 1000 M/MOD SWAP DROP I ATTR @ !DOT INCR 2@ D+ LOOP 2DROP ; : !LINE ( x1 y1 x2 y2 --- ...draw vector) 4DUP ROT - ABS ROT ROT SWAP - ABS < IF XBIGGER ELSE YBIGGER THEN ; ;S ;S ;S
